home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 3 / Gold Medal Software - Volume 3 (Gold Medal) (1994).iso / prog / grafix2.arj / CAPTURE.BAS next >
Encoding:
BASIC Source File  |  1993-11-05  |  5.3 KB  |  212 lines
  1. %waittimer=10
  2. ' This program is a TSR which reads the current text screen and creates
  3. ' a screen 12 image file
  4.  
  5. DUMMY&=SETMEM(-700000)
  6. DUMMY&=SETMEM(256000)
  7.  
  8. POPUP KEY CHR$(12,28,&H70) ' ctrl-alt-enter
  9. DO
  10. POPUP SLEEP USING EMS
  11.     DEF SEG=&Hb800
  12.         O$=PEEK$(0,4000)
  13.         Row%=CSRLIN:COL%=POS(0):Cur%=pbvcursorvis
  14.         SCREEN 12
  15.         p%=1
  16.     FOR x%=1 TO 25
  17.             FOR y%=1 TO 80
  18.                     CHAR$=MID$(O$,p%,1)
  19.                         ATTR??=ASCII(MID$(O$,p%+1,1))
  20.                         Fg%=(ATTR?? AND &HF)
  21.                         Bg%=(ATTR?? \ &H10)
  22.                         CPRINT x%, y%, fg%, bg%, CHAR$
  23.                         INCR p%:INCR p%
  24.                 NEXT y%
  25.         NEXT x%
  26.  
  27.         PUTSCREEN "CAPTURE.12"
  28.         SCREEN 0
  29.         DEF SEG=&Hb800
  30.         POKE$ 0,O$
  31.         MESSAGE "ENTER CAPTURE FILE NAME"
  32.         C$=EDITBOX$("             ")
  33.     IF DIR$(C$)<>"" THEN KILL C$
  34.         NAME "CAPTURE.12" AS C$
  35.         LOCATE Row%, Col%, Cur%
  36.         POKE$ 0,O$
  37. LOOP
  38.  
  39.  
  40.  
  41.  
  42.  
  43. SUB SaveScreen12(R$, G$, B$, I$)
  44. DEF SEG = &HA000
  45. OUT &H3CE, 4: OUT &H3CF, 0:B$=PEEK$(0,32000)
  46. OUT &H3CE, 4: OUT &H3CF, 1:G$=PEEK$(0,32000)
  47. OUT &H3CE, 4: OUT &H3CF, 2:R$=PEEK$(0,32000)
  48. OUT &H3CE, 4: OUT &H3CF, 3:I$=PEEK$(0,32000)
  49. OUT &H3CE, 4: OUT &H3CF, 0:
  50. DEF SEG
  51. END SUB
  52.  
  53. SUB RestoreScreen12(R$, G$, B$, I$)
  54. DEF SEG = &HA000
  55. OUT &H3C4, 2: OUT &H3C5, 1: POKE$ 0,B$
  56. OUT &H3C4, 2: OUT &H3C5, 2: POKE$ 0,G$
  57. OUT &H3C4, 2: OUT &H3C5, 4: POKE$ 0,R$
  58. OUT &H3C4, 2: OUT &H3C5, 8: POKE$ 0,I$
  59. OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG
  60. END SUB
  61.  
  62. SUB PUTSCREEN (Fi$)
  63.     OPEN Fi$ FOR OUTPUT AS #11
  64.     DEF SEG = &HA000
  65.     OUT &H3CE, 4: OUT &H3CF, 2:R$=PEEK$(0,32000)
  66.         PRINT #11, R$;
  67.     OUT &H3CE, 4: OUT &H3CF, 1:r$=PEEK$(0,32000)
  68.         PRINT #11, R$;
  69.     OUT &H3CE, 4: OUT &H3CF, 0:r$=PEEK$(0,32000)
  70.         PRINT #11, R$;
  71.     OUT &H3CE, 4: OUT &H3CF, 3:r$=PEEK$(0,32000)
  72.         PRINT #11, R$;
  73.     OUT &H3CE, 4: OUT &H3CF, 0:
  74.     DEF SEG
  75.         CLOSE #11
  76. END SUB
  77.  
  78. SUB GETSCREEN (Fi$)
  79.     OPEN Fi$ FOR BINARY AS #11
  80.         GET$ #11, 32000, R$
  81.         GET$ #11, 32000, G$
  82.         GET$ #11, 32000, B$
  83.         GET$ #11, 32000, I$
  84.         CLOSE #11
  85.     DEF SEG = &HA000
  86.     OUT &H3C4, 2: OUT &H3C5, 1: POKE$ 0,B$
  87.     OUT &H3C4, 2: OUT &H3C5, 2: POKE$ 0,G$
  88.     OUT &H3C4, 2: OUT &H3C5, 4: POKE$ 0,R$
  89.     OUT &H3C4, 2: OUT &H3C5, 8: POKE$ 0,I$
  90.     OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG
  91. END SUB
  92.  
  93.  
  94.  
  95. SUB mload (Filename$)
  96. SOUND 250, .7: DEF SEG = &HA000
  97. OUT &H3C4, 2: OUT &H3C5, 1: BLOAD FileName$ + ".BLU"  'save bit plane 0
  98. OUT &H3C4, 2: OUT &H3C5, 2: BLOAD FileName$ + ".GRN"  'save bit plane 1
  99. OUT &H3C4, 2: OUT &H3C5, 4: BLOAD FileName$ + ".RED"  'save bit plane 2
  100. OUT &H3C4, 2: OUT &H3C5, 8: BLOAD FileName$ + ".INT"  'save bit plane 3
  101. OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG
  102. SOUND 250, .7
  103. END SUB
  104.  
  105. SUB CWAIT
  106.         T!=TIMER
  107.         DO
  108.         A$=INKEY$
  109.         IF A$=CHR$(27) THEN END
  110.         IF TIMER+%WaitTimer > TIMER THEN EXIT LOOP
  111.         LOOP WHILE A$=""
  112. END SUB
  113.  
  114. SUB CPRINT(Y%,X%,Fore%,Back%,Text$)
  115. IF Back%>=0 THEN
  116.    M$=STRING$(LEN(Text$),219)
  117.    REG 1,&h1300
  118.    REG 2,Back%
  119.    REG 3,LEN(Text$)
  120.    REG 4,256*(Y%-1)+(X%-1)
  121.    REG 9,STRSEG(M$)
  122.    REG 7,STRPTR(M$)
  123.    CALL INTERRUPT &h10
  124.    ELSE
  125.    Back%=NOT Back%-1
  126.    IF Back%=-16 THEN Back%=0
  127. END IF
  128.  
  129. REG 1,&h1300
  130. REG 2,(Fore% XOR Back%) + &h80
  131. REG 3,LEN(Text$)
  132. REG 4,256*(Y%-1)+(X%-1)
  133. REG 9,STRSEG(Text$)
  134. REG 7,STRPTR(Text$)
  135. CALL INTERRUPT &h10
  136. END SUB
  137.  
  138. FUNCTION EditBox$(Default$)
  139.  
  140. COLOR 0,7
  141. CALL SingleBox(19, 38-(LEN(Default$)\2), 21, 42+(LEN(Default$)\2))
  142. y = 40 - (LEN(Default$) \ 2) : YY=0
  143. DO
  144.  
  145.  
  146.    LOCATE 20,Y,0:PRINT Default$  ' if you want to put the box somewhere
  147.    LOCATE  20,Y+yy,1             ' else, change these locate statements
  148.  
  149.  
  150.    DO:A$=INKEY$:LOOP WHILE LEN(A$)=0
  151.    IF LEN(A$) THEN
  152.       SELECT CASE(A$)
  153.       CASE CHR$(27), CHR$(13)
  154.          EXIT SELECT
  155.       CASE CHR$(8)
  156.          IF YY THEN
  157.             YY=YY-1
  158.             IF YY THEN
  159.                Default$=LEFT$(Default$,yy)+MID$(Default$,yy+2) + " "
  160.             ELSE
  161.                Default$=MID$(Default$,yy+2) + " "
  162.             END IF
  163.          END IF
  164.       CASE CHR$(0)+CHR$(83)
  165.          IF YY THEN
  166.             Default$=LEFT$(Default$,yy)+MID$(Default$,yy+2) + " "
  167.          ELSE
  168.             Default$=MID$(Default$,yy+2) + " "
  169.          END IF
  170.       CASE CHR$(0)+CHR$(&H4D)
  171.          IF YY < LEN(Default$) THEN YY=YY+1
  172.       CASE CHR$(0)+CHR$(&H4B)
  173.          IF YY THEN YY=YY-1
  174.       CASE CHR$(0)+CHR$(79) 'end
  175.          yy=LEN(RTRIM$(default$))
  176.       CASE CHR$(0)+CHR$(71)
  177.          yy=0
  178.  
  179.       CASE ELSE
  180.          IF LEN(A$)=1 and YY=0 THEN Default$=SPACE$(LEN(default$))
  181.          IF LEN(A$)=1 and YY < LEN(Default$) THEN_
  182.          MID$(Default$,YY+1,1) = A$ : YY=YY+1
  183.  
  184.       END SELECT
  185.       IF A$=CHR$(27) THEN EditBox$="":EXIT LOOP
  186.       IF A$=CHR$(13) THEN EditBox$=RTRIM$(Default$):EXIT LOOP
  187.  
  188.    END IF
  189. LOOP
  190. END FUNCTION
  191.  
  192.  
  193.  
  194.  
  195. SUB SingleBox (Wa%, Wb%, Wc%, Wd%)
  196.    LOCATE Wa%, Wb%: PRINT CHR$(213) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(184)
  197.    LOCATE Wc%, Wb%: PRINT CHR$(212) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(190)
  198.  
  199.    FOR zxy% = 1 TO Wc% - Wa% - 1
  200.       LOCATE Wa% + zxy%, Wb%
  201.       PRINT CHR$(179) + SPACE$((Wd% - Wb%) - 1) + CHR$(179)
  202.    NEXT zxy%
  203.  
  204. END SUB
  205.  
  206. SUB Message (E$)
  207.    CALL SingleBox(14, 20, 16, 60)
  208.    LOCATE 15, 40 - (LEN(E$) \ 2)
  209.    PRINT E$;
  210. END SUB
  211.  
  212.